home *** CD-ROM | disk | FTP | other *** search
/ Cream of the Crop 1 / Cream of the Crop 1.iso / PROGRAM / TAN_SND.ARJ / FART.PAS < prev    next >
Pascal/Delphi Source File  |  1991-07-28  |  5KB  |  231 lines
  1. { FART.PAS - Demo of music and drum routines for Tandy 1000 and/or PCJr }
  2.  
  3. uses noiz,drums;
  4. var j,k: integer;
  5.  
  6. procedure down(a,b,c: integer);
  7. begin
  8.   drums.down(a,b,c);
  9.   quiet;
  10. end;
  11.  
  12. procedure up(a,b,c: integer);
  13. begin
  14.   drums.up(a,b,c);
  15.   quiet;
  16. end;
  17.  
  18. procedure crash(dur: integer);
  19. begin
  20.   up(1,14,1);
  21.   down(0,dur,1);
  22. end;
  23.  
  24. procedure roll1;
  25. var i: integer;
  26. begin
  27.   for i:=1 to 4 do down(0,2,1);
  28.   for i:=1 to 4 do down(1,2,1);
  29.   for i:=1 to 4 do down(2,2,1);
  30.   for i:=1 to 4 do up(3,2,1);
  31.   down(0,20,1);
  32. end;
  33.  
  34. procedure roll2;
  35. var i: integer;
  36. begin
  37.   for i:=1 to 4 do up(1,2,1);
  38.   for i:=1 to 4 do down(2,2,1);
  39.   for i:=1 to 4 do up(0,2,1);
  40.   for i:=1 to 4 do down(0,3,1);
  41.   up(0,20,1);
  42. end;
  43.  
  44. procedure roll3;
  45. var i: integer;
  46. begin
  47.   bass(2,4);
  48.   lowtom(8,2); tom(8,2); snare(8,2);
  49.   bass(2,4);
  50.   snare(8,2); tom(8,2); lowtom(8,2);
  51.   bass(8,2);
  52.   down(0,20,1);
  53. end;
  54.  
  55. procedure roll4;
  56. begin
  57.   snare(8,2);
  58.   lowtom(4,4); lowtom(4,2);
  59.   tom(4,4); roto1(4,1);
  60. end;
  61.  
  62. procedure filler(b: boolean);
  63. begin
  64.   sound(e2); snare(2,8);
  65.   sound(g2); snare(2,6);
  66.   sound(a3); snare(4,2);
  67.   sound(as2); lowtom(4,4);
  68.   sound(b2); lowtom(4,2);
  69.   sound(d2); tom(4,4);
  70.   sound(b2); bass(4,2);
  71.   sound(d2); snare(2,5);
  72.   bend(d2,e2,40,12,1);
  73.   if b then
  74.   begin
  75.     sound(e2);
  76.     chord(e3,b3,e4,6,12);
  77.     nosound;
  78.     snare(2,2);
  79.   end else
  80.     snare(2,2);
  81. end;
  82.  
  83. procedure lick1(reps,dur: integer);
  84. const
  85.   eblues: array[1..8] of integer =
  86.           (e3,fs3,g3,a4,as4,b4,d4,e4);
  87. var i,j: integer;
  88. begin
  89.   if (reps <= 0) then exit;
  90.   j:=1;
  91.   for i:=1 to reps do
  92.   begin
  93.     j:=1;
  94.     repeat
  95.       plays(eblues[j],dur,0,9,0);
  96.       inc(j);
  97.     until j=9;
  98.     bend(d4,e4,24,2,1);
  99.     plays(g4,20,10,0,0);
  100.     bend(e4,d4,24,2,1);
  101.     quiet;
  102.   end;
  103. end;
  104.  
  105. procedure guitar_solo;
  106. begin
  107.   sound(e2);
  108.   chord(e3,b3,e4,15,25); quiet;
  109.   scale2(e3,g3,a4,as4,b4,d4,ds4,e4,10,2,9,0);
  110.   crash(2); crash(5);
  111.   sound(as2);
  112.   chord(as4,f4,as5,15,25); quiet;
  113.   bend(d5,e5,40,0,3);
  114.   plays(e5,50,0,10,0);
  115.   scale2(g5,e5,d5,b5,g5,e5,d5,b5,25,5,0,0);
  116.   scale2(g5,e5,d5,b5,as5,a5,g4,e4,25,5,0,0);
  117.   bend(d5,e5,40,0,3); plays(g5,50,0,0,0);
  118.   bend(e5,d5,40,4,1); plays(b5,50,0,0,0);
  119.   bend(g5,a6,20,0,3);
  120.   scale2(b6,as6,a6,g5,b6,as6,a6,g5,10,10,0,0);
  121.   bend(d5,e5,20,5,1);
  122.   scale2(g5,e5,d5,b5,as5,a5,g4,e4,0,7,7,0);
  123.   crash(2); crash(6);
  124.   sound(e2);
  125.   echo(40,long);
  126.   chord(e3,b3,e4,1,30);
  127.   down(2,15,1);
  128. end;
  129.  
  130. procedure ending;
  131. begin
  132.   up(1,25,1);
  133.   sound(as2); chord(as4,f4,as5,27,25);
  134.   up(0,25,1);
  135.   sound(c2); chord(g3,c4,g4,27,10);
  136.   up(2,46,1);
  137.   sound(e1); chord(e3,b4,e4,27,15);
  138.   up(1,5,1); down(2,50,1); quiet; halt;
  139. end;
  140.  
  141. procedure beat1(reps: integer);
  142. var i,mode,counter: integer;
  143. label tg;
  144. begin
  145.   k:=0; mode:=0;
  146.   up(2,50,1); filler(true);
  147. Tg:
  148.   case mode of
  149.     0:;
  150.     1: sound(e3);
  151.     2: sound(b3);
  152.     3: begin
  153.          sound(a2); mode:=0;
  154.        end;
  155.   end;
  156.   inc(mode);
  157.   down(2,8,1);
  158.   if (i = 2) then
  159.   begin
  160.     if (k in [12,16,20,24,28,32,36]) then
  161.     begin
  162.       case k of
  163.         12: begin
  164.               sound(g2);
  165.               chord(g2,c3,g4,1,12);
  166.               down(2,15,1);
  167.             end;
  168.         16: begin
  169.               sound(d2);
  170.               chord(d3,a4,c4,1,5);
  171.               down(2,15,1);
  172.             end;
  173.         20: begin
  174.               filler(false);
  175.               sound(e2);
  176.               chord(e3,b3,e4,1,12);
  177.               down(2,15,1);
  178.             end;
  179.         24: begin
  180.               sound(e2); lick1(1,12);
  181.               sound(e2);
  182.               chord(e3,b3,e4,1,30);
  183.               down(2,15,1);
  184.             end;
  185.         28: begin
  186.               sound(as2);
  187.               chord(as4,f4,as5,1,25);
  188.               down(2,15,1);
  189.             end;
  190.         32: guitar_solo;
  191.         36: begin
  192.               sound(as2);
  193.               chord(as4,f4,as5,1,25);
  194.               down(2,15,1);
  195.               k:=0;
  196.             end;
  197.       end;
  198.     end else
  199.     begin
  200.       nosound; 
  201.       sound(e2);
  202.       chord(e3,b3,e4,1,12);
  203.       down(2,15,1);
  204.     end;
  205.   end;
  206.   j:=0; i:=0;
  207.   for counter:=1 to reps do
  208.   begin
  209.     if ((keyhit) and (fkey=#3)) then ending;
  210.     inc(i); inc(j); inc(k);
  211.     down(0,5,1);
  212.     wait(50);
  213.     if j=2 then
  214.     begin
  215.       up(1,5,1); j:=11; i:=0;
  216.     end;
  217.     if (i = 2) then goto tg;
  218.     down(0,3,1);
  219.     down(2,8,1);
  220.     down(2,8,1);
  221.   end;
  222.   roll1; crash(15);
  223. end;
  224.  
  225. begin
  226.   drums.inturbo:=false; noiz.inturbo:=false;
  227.   roll3; roll2; roll1;
  228.   writeln('Hit Crtl-C to End');
  229.   beat1(8);
  230. end.
  231.